home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / predicate.c < prev    next >
Encoding:
C/C++ Source or Header  |  1987-06-04  |  11.6 KB  |  723 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     predicate.c
  9.  
  10.     predicates
  11. */
  12.  
  13. #include "include.h"
  14.  
  15. Lnull()
  16. {
  17.     check_arg(1);
  18.  
  19.     if (vs_base[0] == Cnil)
  20.         vs_base[0] = Ct;
  21.     else
  22.         vs_base[0] = Cnil;
  23. }
  24.  
  25. Lsymbolp()
  26. {
  27.     check_arg(1);
  28.  
  29.     if (type_of(vs_base[0]) == t_symbol)
  30.         vs_base[0] = Ct;
  31.     else
  32.         vs_base[0] = Cnil;
  33. }
  34.  
  35. Latom()
  36. {
  37.     check_arg(1);
  38.  
  39.     if (type_of(vs_base[0]) != t_cons)
  40.         vs_base[0] = Ct;
  41.     else
  42.         vs_base[0] = Cnil;
  43. }
  44.  
  45. Lconsp()
  46. {
  47.     check_arg(1);
  48.  
  49.     if (type_of(vs_base[0]) == t_cons)
  50.         vs_base[0] = Ct;
  51.     else
  52.         vs_base[0] = Cnil;
  53. }
  54.  
  55. Llistp()
  56. {
  57.     check_arg(1);
  58.  
  59.     if (vs_base[0] == Cnil || type_of(vs_base[0]) == t_cons)
  60.         vs_base[0] = Ct;
  61.     else
  62.         vs_base[0] = Cnil;
  63. }
  64.  
  65. Lnumberp()
  66. {
  67.     enum type t;
  68.     check_arg(1);
  69.  
  70.     t = type_of(vs_base[0]);
  71.     if (t == t_fixnum || t == t_bignum || t == t_ratio ||
  72.         t == t_shortfloat || t == t_longfloat ||
  73.         t == t_complex)
  74.         vs_base[0] = Ct;
  75.     else
  76.         vs_base[0] = Cnil;
  77. }
  78.  
  79. Lintegerp()
  80. {
  81.     enum type t;
  82.     check_arg(1);
  83.  
  84.     t = type_of(vs_base[0]);
  85.     if (t == t_fixnum || t == t_bignum)
  86.         vs_base[0] = Ct;
  87.     else
  88.         vs_base[0] = Cnil;
  89. }
  90.  
  91. Lrationalp()
  92. {
  93.     enum type t;
  94.     check_arg(1);
  95.  
  96.     t = type_of(vs_base[0]);
  97.     if (t == t_fixnum || t == t_bignum || t == t_ratio)
  98.         vs_base[0] = Ct;
  99.     else
  100.         vs_base[0] = Cnil;
  101. }
  102.  
  103. Lfloatp()
  104. {
  105.     enum type t;
  106.     check_arg(1);
  107.  
  108.     t = type_of(vs_base[0]);
  109.     if (t == t_longfloat || t == t_shortfloat)
  110.         vs_base[0] = Ct;
  111.     else
  112.         vs_base[0] = Cnil;
  113. }
  114.  
  115. Lcomplexp()
  116. {
  117.     check_arg(1);
  118.  
  119.     if (type_of(vs_base[0]) == t_complex)
  120.         vs_base[0] = Ct;
  121.     else
  122.         vs_base[0] = Cnil;
  123. }
  124.  
  125. Lcharacterp()
  126. {
  127.     check_arg(1);
  128.  
  129.     if (type_of(vs_base[0]) == t_character)
  130.         vs_base[0] = Ct;
  131.     else
  132.         vs_base[0] = Cnil;
  133. }
  134.  
  135. Lstringp()
  136. {
  137.     check_arg(1);
  138.  
  139.     if (type_of(vs_base[0]) == t_string)
  140.         vs_base[0] = Ct;
  141.     else
  142.         vs_base[0] = Cnil;
  143. }
  144.  
  145. Lbit_vector_p()
  146. {
  147.     check_arg(1);
  148.  
  149.     if (type_of(vs_base[0]) == t_bitvector)
  150.         vs_base[0] = Ct;
  151.     else
  152.         vs_base[0] = Cnil;
  153. }
  154.  
  155. Lvectorp()
  156. {
  157.     enum type t;
  158.     check_arg(1);
  159.  
  160.     t = type_of(vs_base[0]);
  161.     if (t == t_vector || t == t_string || t == t_bitvector)
  162.         vs_base[0] = Ct;
  163.     else
  164.         vs_base[0] = Cnil;
  165. }
  166.  
  167. Lsimple_string_p()
  168. {
  169.     check_arg(1);
  170.  
  171.     if (type_of(vs_base[0]) == t_string &&
  172.         !vs_base[0]->st.st_adjustable &&
  173.         !vs_base[0]->st.st_hasfillp &&
  174.         vs_base[0]->st.st_displaced->c.c_car == Cnil)
  175.         vs_base[0] = Ct;
  176.     else
  177.         vs_base[0] = Cnil;
  178. }
  179.  
  180. Lsimple_bit_vector_p()
  181. {
  182.     check_arg(1);
  183.  
  184.     if (type_of(vs_base[0]) == t_bitvector &&
  185.         !vs_base[0]->bv.bv_adjustable &&
  186.         !vs_base[0]->bv.bv_hasfillp &&
  187.         vs_base[0]->bv.bv_displaced->c.c_car == Cnil)
  188.         vs_base[0] = Ct;
  189.     else
  190.         vs_base[0] = Cnil;
  191. }
  192.  
  193. Lsimple_vector_p()
  194. {
  195.     enum type t;
  196.     check_arg(1);
  197.  
  198.     t = type_of(vs_base[0]);
  199.     if (t == t_vector &&
  200.         !vs_base[0]->v.v_adjustable &&
  201.         !vs_base[0]->v.v_hasfillp &&
  202.         vs_base[0]->v.v_displaced->c.c_car == Cnil &&
  203.         (enum aelttype)vs_base[0]->v.v_elttype == aet_object)
  204.         vs_base[0] = Ct;
  205.     else
  206.         vs_base[0] = Cnil;
  207. }
  208.  
  209. Larrayp()
  210. {
  211.     enum type t;
  212.     check_arg(1);
  213.  
  214.     t = type_of(vs_base[0]);
  215.     if (t == t_array ||
  216.         t == t_vector || t == t_string || t == t_bitvector)
  217.         vs_base[0] = Ct;
  218.     else
  219.         vs_base[0] = Cnil;
  220. }
  221.  
  222. Lpackagep()
  223. {
  224.     check_arg(1);
  225.  
  226.     if (type_of(vs_base[0]) == t_package)
  227.         vs_base[0] = Ct;
  228.     else
  229.         vs_base[0] = Cnil;
  230. }
  231.  
  232. Lfunctionp()
  233. {
  234.     enum type t;
  235.     object x;
  236.  
  237.     check_arg(1);
  238.     t = type_of(vs_base[0]);
  239.     if (t == t_cfun || t == t_cclosure)
  240.         vs_base[0] = Ct;
  241.     else if (t == t_symbol) {
  242.         if (vs_base[0]->s.s_gfdef != OBJNULL &&
  243.             vs_base[0]->s.s_mflag == FALSE)
  244.             vs_base[0] = Ct;
  245.         else
  246.             vs_base[0] = Cnil;
  247.     } else if (t == t_cons) {
  248.         x = vs_base[0]->c.c_car;
  249.         if (x == Slambda || x == Slambda_block ||
  250.             x == Slambda_closure || x == Slambda_block_closure)
  251.             vs_base[0] = Ct;
  252.         else
  253.             vs_base[0] = Cnil;
  254.     } else
  255.         vs_base[0] = Cnil;
  256. }
  257.  
  258. Lcompiled_function_p()
  259. {
  260.     check_arg(1);
  261.  
  262.     if (type_of(vs_base[0]) == t_cfun ||
  263.         type_of(vs_base[0]) == t_cclosure)
  264.         vs_base[0] = Ct;
  265.     else
  266.         vs_base[0] = Cnil;
  267. }
  268.  
  269. Lcommonp()
  270. {
  271.     check_arg(1);
  272.  
  273.     if (type_of(vs_base[0]) != t_spice)
  274.         vs_base[0] = Ct;
  275.     else
  276.         vs_base[0] = Cnil;
  277. }
  278.  
  279. Leq()
  280. {
  281.     check_arg(2);
  282.  
  283.     if (vs_base[0] == vs_base[1])
  284.         vs_base[0] = Ct;
  285.     else
  286.         vs_base[0] = Cnil;
  287.     vs_pop;
  288. }
  289.  
  290. bool
  291. eql(x, y)
  292. object x, y;
  293. {
  294.     enum type t;
  295.  
  296.     if (x == y)
  297.         return(TRUE);
  298.     if ((t = type_of(x)) != type_of(y))
  299.         return(FALSE);
  300.     switch (t) {
  301.  
  302.     case t_fixnum:
  303.         if (fix(x) == fix(y))
  304.             return(TRUE);
  305.         else
  306.             return(FALSE);
  307.  
  308.     case t_bignum:
  309.         if (big_compare((struct bignum *)x,
  310.                 (struct bignum *)y) == 0)
  311.             return(TRUE);
  312.         else
  313.             return(FALSE);
  314.  
  315.     case t_ratio:
  316.         if (eql(x->rat.rat_num, y->rat.rat_num) &&
  317.             eql(x->rat.rat_den, y->rat.rat_den))
  318.             return(TRUE);
  319.         else
  320.             return(FALSE);
  321.  
  322.     case t_shortfloat:
  323.         if (sf(x) == sf(y))
  324.             return(TRUE);
  325.         else
  326.             return(FALSE);
  327.  
  328.     case t_longfloat:
  329.         if (lf(x) == lf(y))
  330.             return(TRUE);
  331.         else
  332.             return(FALSE);
  333.  
  334.     case t_complex:
  335.         if (eql(x->cmp.cmp_real, y->cmp.cmp_real) &&
  336.             eql(x->cmp.cmp_imag, y->cmp.cmp_imag))
  337.             return(TRUE);
  338.         else
  339.             return(FALSE);
  340.  
  341.     case t_character:
  342.         if (char_code(x) == char_code(y) &&
  343.             char_bits(x) == char_bits(y) &&
  344.             char_font(x) == char_font(y))
  345.             return(TRUE);
  346.         else
  347.             return(FALSE);
  348.     }
  349.     return(FALSE);
  350. }
  351.  
  352. Leql()
  353. {
  354.     check_arg(2);
  355.  
  356.     if (eql(vs_base[0], vs_base[1]))
  357.         vs_base[0] = Ct;
  358.     else
  359.         vs_base[0] = Cnil;
  360.     vs_pop;
  361. }
  362.  
  363. bool
  364. equal(x, y)
  365. object x, y;
  366. {
  367.     enum type t;
  368.  
  369.     cs_check(x);
  370.  
  371. BEGIN:
  372.     if ((t = type_of(x)) != type_of(y))
  373.         return(FALSE);
  374.     if (eql(x, y))
  375.         return(TRUE);
  376.     switch (t) {
  377.  
  378.     case t_cons:
  379.         if (!equal(x->c.c_car, y->c.c_car))
  380.             return(FALSE);
  381.         x = x->c.c_cdr;
  382.         y = y->c.c_cdr;
  383.         goto BEGIN;
  384.  
  385.     case t_string:
  386.         return(string_eq(x, y));
  387.  
  388.     case t_bitvector:
  389.     {
  390.         int i, ox, oy;
  391.  
  392.         if (x->bv.bv_fillp != y->bv.bv_fillp)
  393.             return(FALSE);
  394.         ox = x->bv.bv_offset;
  395.         oy = y->bv.bv_offset;
  396.         for (i = 0;  i < x->bv.bv_fillp;  i++)
  397.             if((x->bv.bv_self[(i+ox)/8] & (0200>>(i+ox)%8))
  398.              !=(y->bv.bv_self[(i+oy)/8] & (0200>>(i+oy)%8)))
  399.                 return(FALSE);
  400.         return(TRUE);
  401.     }
  402.  
  403.     case t_structure:
  404.     {
  405.         int i;
  406.  
  407.         if (x->str.str_name != y->str.str_name)
  408.             return(FALSE);
  409.         for (i = 0;  i < x->str.str_length;  i++)
  410.             if (!equal(x->str.str_self[i], y->str.str_self[i]))
  411.                 return(FALSE);
  412.         return(TRUE);
  413.     }
  414.  
  415.     case t_pathname:
  416. #ifdef UNIX
  417.         if (equal(x->pn.pn_host, y->pn.pn_host) &&
  418.             equal(x->pn.pn_device, y->pn.pn_device) &&
  419.             equal(x->pn.pn_directory, y->pn.pn_directory) &&
  420.             equal(x->pn.pn_name, y->pn.pn_name) &&
  421.             equal(x->pn.pn_type, y->pn.pn_type) &&
  422.             equal(x->pn.pn_version, y->pn.pn_version))
  423. #endif
  424. #ifdef AOSVS
  425.  
  426.  
  427.  
  428.  
  429.  
  430.  
  431. #endif
  432.             return(TRUE);
  433.         else
  434.             return(FALSE);
  435.  
  436.     }
  437.     return(FALSE);
  438. }
  439.  
  440. Lequal()
  441. {
  442.     check_arg(2);
  443.  
  444.     if (equal(vs_base[0], vs_base[1]))
  445.         vs_base[0] = Ct;
  446.     else
  447.         vs_base[0] = Cnil;
  448.     vs_pop;
  449. }
  450.  
  451. bool
  452. equalp(x, y)
  453. object x, y;
  454. {
  455.     enum type tx, ty;
  456.  
  457.     cs_check(x);
  458.  
  459. BEGIN:
  460.     if (eql(x, y))
  461.         return(TRUE);
  462.     tx = type_of(x);
  463.     ty = type_of(y);
  464.  
  465.     switch (tx) {
  466.     case t_fixnum:
  467.     case t_bignum:
  468.     case t_ratio:
  469.     case t_shortfloat:
  470.     case t_longfloat:
  471.     case t_complex:
  472.         if (ty == t_fixnum || ty == t_bignum || ty == t_ratio ||
  473.             ty == t_shortfloat || ty == t_longfloat ||
  474.             ty == t_complex)
  475.             return(!number_compare(x, y));
  476.         else
  477.             return(FALSE);
  478.  
  479.     case t_vector:
  480.     case t_string:
  481.     case t_bitvector:
  482.         if (ty == t_vector || ty == t_string || ty == t_bitvector)
  483.             goto ARRAY;
  484.         else
  485.             return(FALSE);
  486.  
  487.     case t_array:
  488.         if (ty == t_array && x->a.a_rank != y->a.a_rank)
  489.             goto ARRAY;
  490.         else
  491.             return(FALSE);
  492.     }
  493.     if (tx != ty)
  494.         return(FALSE);
  495.     switch (tx) {
  496.     case t_character:
  497.         return(char_equal(x, y));
  498.  
  499.     case t_cons:
  500.         if (!equalp(x->c.c_car, y->c.c_car))
  501.             return(FALSE);
  502.         x = x->c.c_cdr;
  503.         y = y->c.c_cdr;
  504.         goto BEGIN;
  505.  
  506.     case t_structure:
  507.     {
  508.         int i;
  509.  
  510.         if (x->str.str_name != y->str.str_name)
  511.             return(FALSE);
  512.         for (i = 0;  i < x->str.str_length;  i++)
  513.             if (!equalp(x->str.str_self[i], y->str.str_self[i]))
  514.                 return(FALSE);
  515.         return(TRUE);
  516.     }
  517.  
  518.     case t_pathname:
  519.         return(equal(x, y));
  520.     }
  521.     return(FALSE);
  522.  
  523. ARRAY:
  524.  
  525.     {
  526.         int i, j;
  527.  
  528.         if (x->a.a_dim != y->a.a_dim)
  529.             return(FALSE);
  530.         vs_push(Cnil);
  531.         vs_push(Cnil);
  532.         for (i = 0, j = x->a.a_dim;  i < j;  i++) {
  533.             vs_top[-2] = aref(x, i);
  534.             vs_top[-1] = aref(y, i);
  535.             if (!equalp(vs_top[-2], vs_top[-1])) {
  536.                 vs_pop;
  537.                 vs_pop;
  538.                 return(FALSE);
  539.             }
  540.         }
  541.         vs_pop;
  542.         vs_pop;
  543.         return(TRUE);
  544.     }
  545. }
  546.  
  547. Lequalp()
  548. {
  549.     check_arg(2);
  550.  
  551.     if (equalp(vs_base[0], vs_base[1]))
  552.         vs_base[0] = Ct;
  553.     else
  554.         vs_base[0] = Cnil;
  555.     vs_pop;
  556. }
  557.  
  558. Fand(args)
  559. object args;
  560. {
  561.     object *top = vs_top;
  562.  
  563.     if (endp(args)) {
  564.         vs_base = vs_top;
  565.         vs_push(Ct);
  566.         return;
  567.     }
  568.     while (!endp(MMcdr(args))) {
  569.         eval(MMcar(args));
  570.         if (vs_base[0] == Cnil) {
  571.             vs_base = vs_top = top;
  572.             vs_push(Cnil);
  573.             return;
  574.         }
  575.         vs_top = top;
  576.         args = MMcdr(args);
  577.     }
  578.     eval(MMcar(args));
  579. }
  580.  
  581. For(args)
  582. object args;
  583. {
  584.     object *top = vs_top;
  585.  
  586.     if (endp(args)) {
  587.         vs_base = vs_top;
  588.         vs_push(Cnil);
  589.         return;
  590.     }
  591.     while (!endp(MMcdr(args))) {
  592.         eval(MMcar(args));
  593.         if (vs_base[0] != Cnil) {
  594.             top[0] = vs_base[0];
  595.             vs_base = top;
  596.             vs_top = top+1;
  597.             return;
  598.         }
  599.         vs_top = top;
  600.         args = MMcdr(args);
  601.     }
  602.     eval(MMcar(args));
  603. }
  604.  
  605. /*
  606.     Contains_sharp_comma returns TRUE, iff the argument contains
  607.     a cons whose car is si:|#,| or a STRUCTURE.
  608.     Refer to the compiler about this magic.
  609. */
  610. bool
  611. contains_sharp_comma(x)
  612. object x;
  613. {
  614.     enum type tx;
  615.  
  616.     cs_check(x);
  617.  
  618. BEGIN:
  619.     tx = type_of(x);
  620.     if (tx == t_complex)
  621.         return(contains_sharp_comma(x->cmp.cmp_real) ||
  622.                contains_sharp_comma(x->cmp.cmp_imag));
  623.     if (tx == t_vector)
  624.     {
  625.         int i;
  626.  
  627.         for (i = 0;  i < x->v.v_fillp;  i++)
  628.             if (contains_sharp_comma(x->v.v_self[i]))
  629.                 return(TRUE);
  630.         return(FALSE);
  631.     }
  632.     if (tx == t_cons) {
  633.         if (x->c.c_car == siSsharp_comma)
  634.             return(TRUE);
  635.         if (contains_sharp_comma(x->c.c_car))
  636.             return(TRUE);
  637.         x = x->c.c_cdr;
  638.         goto BEGIN;
  639.     }
  640.     if (tx == t_array)
  641.     {
  642.         int i, j;
  643.  
  644.         for (i = 0, j = 1;  i < x->a.a_rank;  i++)
  645.             j *= x->a.a_dims[i];
  646.         for (i = 0;  i < j;  i++)
  647.             if (contains_sharp_comma(x->a.a_self[i]))
  648.                 return(TRUE);
  649.         return(FALSE);
  650.     }
  651.     if (tx == t_structure)
  652.         return(TRUE);        /*  Oh, my god!  */
  653.     return(FALSE);
  654. }
  655.  
  656. siLcontains_sharp_comma()
  657. {
  658.     check_arg(1);
  659.  
  660.     if (contains_sharp_comma(vs_base[0]))
  661.         vs_base[0] = Ct;
  662.     else
  663.         vs_base[0] = Cnil;
  664. }
  665.  
  666. siLspicep()
  667. {
  668.     check_arg(1);
  669.     if (type_of(vs_base[0]) == t_spice)
  670.         vs_base[0] = Ct;
  671.     else
  672.         vs_base[0] = Cnil;
  673. }
  674.  
  675. siLfixnump()
  676. {
  677.     check_arg(1);
  678.     if (type_of(vs_base[0]) == t_fixnum)
  679.         vs_base[0] = Ct;
  680.     else
  681.         vs_base[0] = Cnil;
  682. }
  683.  
  684. init_predicate_function()
  685. {
  686.     make_function("NULL", Lnull);
  687.     make_function("SYMBOLP", Lsymbolp);
  688.     make_function("ATOM", Latom);
  689.     make_function("CONSP", Lconsp);
  690.     make_function("LISTP", Llistp);
  691.     make_function("NUMBERP", Lnumberp);
  692.     make_function("INTEGERP", Lintegerp);
  693.     make_function("RATIONALP", Lrationalp);
  694.     make_function("FLOATP", Lfloatp);
  695.     make_function("COMPLEXP", Lcomplexp);
  696.     make_function("CHARACTERP", Lcharacterp);
  697.     make_function("STRINGP", Lstringp);
  698.     make_function("BIT-VECTOR-P", Lbit_vector_p);
  699.     make_function("VECTORP", Lvectorp);
  700.     make_function("SIMPLE-STRING-P", Lsimple_string_p);
  701.     make_function("SIMPLE-BIT-VECTOR-P", Lsimple_bit_vector_p);
  702.     make_function("SIMPLE-VECTOR-P", Lsimple_vector_p);
  703.     make_function("ARRAYP", Larrayp);
  704.     make_function("PACKAGEP", Lpackagep);
  705.     make_function("FUNCTIONP", Lfunctionp);
  706.     make_function("COMPILED-FUNCTION-P", Lcompiled_function_p);
  707.     make_function("COMMONP", Lcommonp);
  708.  
  709.     make_function("EQ", Leq);
  710.     make_function("EQL", Leql);
  711.     make_function("EQUAL", Lequal);
  712.     make_function("EQUALP", Lequalp);
  713.  
  714.     make_function("NOT", Lnull);
  715.     make_special_form("AND",Fand);
  716.     make_special_form("OR",For);
  717.  
  718.     make_si_function("CONTAINS-SHARP-COMMA", siLcontains_sharp_comma);
  719.  
  720.     make_si_function("FIXNUMP", siLfixnump);
  721.     make_si_function("SPICEP", siLspicep);
  722. }
  723.